home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / TARCHIV.ZIP / ARC.PAS next >
Pascal/Delphi Source File  |  1995-01-27  |  20KB  |  747 lines
  1. { ARC.TPU }
  2.  
  3. { Andreas Schiffler, U of S, 1994 }
  4.  
  5. { This unit contains all essential archiver routines and is made to work }
  6. { with files. I/O primitives can be overridden to adapt the any device.  }
  7. { The I/O functions are sequential and block oriented, i.e. for tape.    }
  8.  
  9. Unit Arc;
  10.  
  11. Interface
  12.  
  13. Uses Dos, Objects, Logfile, ToolBox;
  14.  
  15. Const
  16.      Blocksize   = 32*1024;
  17.      MagicCode   = 'rchi';
  18.      DirItemSize = 13+3*4;
  19.  
  20. Type
  21.      tIOMode    = (fRead,fWrite);
  22.  
  23.      PByteArray = ^TByteArray;
  24.      TByteArray = Array[0..65527] Of Byte;
  25.  
  26.      PBlock     = ^TBlock;
  27.      TBlock     = Array [0..(Blocksize-1)] Of Byte;
  28.  
  29.      TArchiveHeader = Record
  30.                        Magic     : String[6];
  31.                        Filename  : String[12];
  32.                        Filesize  : Longint;
  33.                        Time      : Longint;
  34.                       End;
  35.  
  36.      TChecksum = Longint;
  37.  
  38.      PDirItem = ^TDirItem;
  39.      TDirItem = object (TObject)
  40.                  Filename  : String[12];
  41.                  Filesize  : Longint;
  42.                  Time      : Longint;
  43.                  Position  : Longint;
  44.                  Constructor Init (NewFilename : String;
  45.                                    NewFilesize : Longint;
  46.                                    NewTime     : Longint;
  47.                                    NewPosition : Longint);
  48.                  Procedure   Store(var S: TStream);
  49.                  Constructor Load(var S: TStream);
  50.                 end;
  51.  
  52.      PDirCollection = ^TDirCollection;
  53.      TDirCollection = object (TSortedCollection)
  54.                        function Compare(Key1, Key2: Pointer): Integer; virtual;
  55.                       end;
  56.  
  57.      PArchiver = ^TArchiver;
  58.      TArchiver = Object
  59.                   FileBlock     : PBlock;
  60.                   Block         : PBlock;
  61.                   BlockNum      : Longint;      { current block number }
  62.                   BlockOfs      : Word;         { current pos in block }
  63.                   ArchiveFilename   : String;
  64.                   ArchiveName       : String[12];
  65.                   DirectoryFilename : String[12];
  66.                   ArchiveFile    : File;
  67.                   IOMode         : tIOMode;
  68.                   DirCollection  : PDirCollection;
  69.                   Checksum       : Longint;
  70.                   DisplayFlag    : Boolean;
  71.                   DirectorySize  : Longint;      { set by ReadDirectory }
  72.                   TotalSize      : Longint;
  73.                   TotalFiles     : Longint;
  74.                   Wordy          : Boolean;
  75.                   LongItemFlag   : Boolean;
  76.  
  77.                   ErrorLog       : PLogfile;
  78.                   InfoLog        : PLogfile;
  79.  
  80.                   { File-archive specifics }
  81.                   Constructor Init (Archive : String; NewIOMode : tIOMode);
  82.                   Destructor  Done; virtual;
  83.                   Procedure   ErrorCheck (Where : String);
  84.                   Procedure   ReadDirectory;
  85.                   Procedure   WriteDirectory;
  86.                   Procedure   EraseDirectory;
  87.  
  88.                   { Archive handling }
  89.                   Procedure AddFiles (Wildcard : String);
  90.                   Procedure AddFile (Item : PDirItem);
  91.                   Procedure ExtractFiles (Wildcard : String);
  92.                   Procedure DisplayItem(Item : PDirItem);
  93.                   Procedure ExtractNextFile;
  94.  
  95.                   { Block primitives }
  96.                   Procedure Put (Buffer : Pointer; Count : Word);
  97.                   Procedure Get (Buffer : Pointer; Count : Word);
  98.  
  99.                   { I/O primitives }
  100.                   Procedure OpenArchive; virtual;
  101.                   Procedure CloseArchive; virtual;
  102.                   Procedure ReadBlock; virtual;
  103.                   Procedure WriteBlock; virtual;
  104.                   Procedure SeekBlock (NewBlockNum : Longint); virtual;
  105.                  End;
  106.  
  107. { ========== }
  108.  
  109. Implementation
  110.  
  111. Const
  112.   RDirItem : TStreamRec = (
  113.      ObjType: 10020;
  114.      VmtLink: Ofs(TypeOf(TDirItem)^);
  115.      Load:    @TDirItem.Load;
  116.      Store:   @TDirItem.Store
  117.   );
  118.  
  119.   RDirCollection : TStreamRec = (
  120.      ObjType: 10021;
  121.      VmtLink: Ofs(TypeOf(TDirCollection)^);
  122.      Load:    @TDirCollection.Load;
  123.      Store:   @TDirCollection.Store
  124.   );
  125.  
  126. Constructor TDirItem.Init (NewFilename : String;
  127.                            NewFilesize : Longint;
  128.                            NewTime     : Longint;
  129.                            NewPosition : Longint);
  130. Begin
  131.  Inherited Init;
  132.  Filename := NewFilename;
  133.  Filesize := NewFilesize;
  134.  Time     := NewTime;
  135.  Position := NewPosition;
  136. End;
  137.  
  138. Procedure TDirItem.Store(var S: TStream);
  139. Begin
  140.  S.Write (Filename,SizeOf(Filename));
  141.  S.Write (Filesize,SizeOf(Filesize));
  142.  S.Write (Time,SizeOf(Time));
  143.  S.Write (Position,SizeOf(Position));
  144. End;
  145.  
  146. Constructor TDirItem.Load(var S: TStream);
  147. Begin
  148.  inherited Init;
  149.  S.Read (Filename,SizeOf(Filename));
  150.  S.Read (Filesize,SizeOf(Filesize));
  151.  S.Read (Time,SizeOf(Time));
  152.  S.Read (Position,SizeOf(Position));
  153. End;
  154.  
  155. Function TDirCollection.Compare(Key1, Key2: Pointer): Integer;
  156. Begin
  157.  If PDirItem(Key1)^.Filename<PDirItem(Key2)^.Filename Then
  158.    Compare := -1
  159.  Else If PDirItem(Key1)^.Filename>PDirItem(Key2)^.Filename Then
  160.    Compare := 1
  161.  Else
  162.    Compare := 0;
  163. End;
  164.  
  165. Function ParseDosError : String;
  166. Var
  167.  S,SS: String;
  168. Begin
  169.  Case DosError Of
  170.    2:  S:='File not found';
  171.    3:  S:='Path not found';
  172.    5:  S:='Access denied';
  173.    6:  S:='Invalid handle';
  174.    8:  S:='Not enough memory';
  175.   10:  S:='Invalid environment';
  176.   11:  S:='Invalid format';
  177.   18:  S:='No more files';
  178.  Else
  179.   S:='Unknown';
  180.  End;
  181.  Str (DosError:2,SS);
  182.  ParseDosError :='DOS error #'+SS+': '+S;
  183.  DosError := 0;
  184. End;
  185.  
  186. Function ParseIOResult(I:Integer) : String;
  187. Var
  188.  S,SS : String;
  189. Begin
  190.  Case I of
  191.   100: S:='Disk read error';
  192.   101: S:='Disk write error';
  193.   102: S:='File not assigned';
  194.   103: S:='File not open';
  195.   104: S:='File not open for input';
  196.   105: S:='File not open for output';
  197.   106: S:='Invalid numeric format';
  198.   150: S:='Disk is write protected';
  199.   151: S:='Unknown unit';
  200.   152: S:='Drive not ready';
  201.   153: S:='Unknown command';
  202.   154: S:='CRC error in data';
  203.   155: S:='Bad drive request structure length';
  204.   156: S:='Disk seek error';
  205.   157: S:='Unknown media type';
  206.   158: S:='Sector not found';
  207.   159: S:='Printer out of paper';
  208.   160: S:='Device write fault';
  209.   161: S:='Device read fault';
  210.   162: S:='Hardware failure';
  211.  Else
  212.   S:='Unknown';
  213.  End;
  214.  Str(I:3,SS);
  215.  ParseIOResult := 'IOError #'+SS+': '+S;
  216. End;
  217.  
  218. { Sum buffer to form a checksum }
  219. Function CRC (Var CRCBlock : TBlock; Count : Word) : Word;
  220. Begin
  221.  Asm
  222.     PUSH DS
  223.     LDS SI, CRCBlock { Source        DS:SI }
  224.     MOV CX, Count    { Count }
  225.     MOV AH, 0
  226.     MOV BX, 0
  227.     CLD              { forward }
  228.     @TheLoop:
  229.      LODSB
  230.      ADD BX,AX
  231.     Loop @TheLoop
  232.     MOV @Result,BX
  233.     POP DS
  234.  End;
  235. End;
  236.  
  237. Procedure TArchiver.ErrorCheck (Where : String);
  238. Var
  239.  I : Integer;
  240. Begin
  241.  I := IOResult;
  242.  If I<>0 Then ErrorLog^.Writelog('['+Where+'] '+ParseIOResult(I));
  243.  If DosError<>0 Then ErrorLog^.Writelog('['+Where+'] '+ParseDosError);
  244. End;
  245.  
  246. Constructor TArchiver.Init (Archive : String; NewIOMode : tIOMode);
  247. Var
  248.   Dir      : DirStr;
  249.   Name     : NameStr;
  250.   Ext      : ExtStr;
  251. Begin
  252.  { Parameters }
  253.  IOMode := NewIOMode;
  254.  DisplayFlag := False;
  255.  TotalSize := 0;
  256.  TotalFiles := 0;
  257.  Wordy := False;
  258.  LongItemFlag := True;
  259.  ArchiveFilename := FExpand(Archive);
  260.  FSplit (ArchiveFilename,Dir,Name,Ext);
  261.  ArchiveName := Name+Ext;
  262.  DirectoryFilename := '#'+Copy(Name,1,7)+'.DIR';
  263.  { Logfiles }
  264.  New (ErrorLog,Init('Error.Log'));
  265.  New (InfoLog,Init(''));
  266.  { Data storage }
  267.  New (Block);
  268.  If Block=NIL Then Begin
  269.   ErrorLog^.Writelog ('Allocation of write block: Out of memory');
  270.   Fail;
  271.  End;
  272.  New (FileBlock);
  273.  If FileBlock=NIL Then Begin
  274.   ErrorLog^.Writelog ('Allocation of read block: Out of memory');
  275.   Fail;
  276.  End;
  277.  FillChar (Block^,SizeOf(TBlock),0);
  278.  FillChar (FileBlock^,SizeOf(TBlock),0);
  279.  New (DirCollection,Init(100,100));
  280.  If DirCollection=NIL Then Begin
  281.   ErrorLog^.Writelog ('Allocation of directory: Out of memory');
  282.   Fail;
  283.  End;
  284.  { Open }
  285.  OpenArchive;
  286. End;
  287.  
  288. Procedure TArchiver.ReadDirectory;
  289. Var
  290.   S : PBufStream;
  291.   R : SearchRec;
  292. Begin
  293.  If Wordy Then InfoLog^.Writelog ('Reading temporary directory '+DirectoryFilename);
  294.  FindFirst (DirectoryFilename,Archive,R);
  295.  DirectorySize := R.Size+SizeOf(TArchiveHeader)+SizeOf(TChecksum);
  296.  New (S,Init(DirectoryFilename,stOpenRead,1024));
  297.  DirCollection^.Load (S^);
  298.  Dispose(S,Done);
  299. End;
  300.  
  301. Procedure TArchiver.WriteDirectory;
  302. Var
  303.   S : PBufStream;
  304. Begin
  305.  If Wordy Then InfoLog^.Writelog ('Writing temporary directory '+DirectoryFilename);
  306.  New (S,Init(DirectoryFilename,stCreate,1024));
  307.  DirCollection^.Store (S^);
  308.  Dispose(S,Done);
  309. End;
  310.  
  311. Procedure TArchiver.EraseDirectory;
  312. Var
  313.   F : File;
  314. Begin
  315.  If Wordy Then InfoLog^.Writelog ('Erasing temporary directory '+DirectoryFilename);
  316.  {$I-}
  317.  Assign (F,DirectoryFilename);
  318.  {$I+}
  319.  ErrorCheck ('Erasing directory');
  320.  Erase (F);
  321. End;
  322.  
  323. Destructor TArchiver.Done;
  324. Var
  325.  S1,S2 : String;
  326. Begin
  327.  Str (TotalSize,S1);
  328.  Str (TotalFiles,S2);
  329.  Commas (S1);
  330.  If Wordy Then InfoLog^.Writelog ('Processed '+S1+' bytes in '+S2+' files.');
  331.  { Close }
  332.  CloseArchive;
  333.  { Data }
  334.  Dispose (Block);
  335.  Dispose (FileBlock);
  336.  Dispose (DirCollection,Done);
  337.  Dispose (ErrorLog);
  338.  Dispose (InfoLog);
  339.  { Erase directory }
  340.  EraseDirectory;
  341. End;
  342.  
  343. Procedure TArchiver.AddFiles (Wildcard : String);
  344. Var
  345.   T        : Text;
  346.   Filename : String[12];
  347.   Location : Longint;
  348.   S        : SearchRec;
  349.   Count    : Integer;
  350.   Item     : PDirItem;
  351. Begin
  352.  { Build directory }
  353.  If Wordy Then InfoLog^.Writelog ('Building directory');
  354.  Wildcard := Upper(Wildcard);
  355.  If Length(Wildcard)>0 Then Begin
  356.   If (Wildcard[1]='@') And (Length(Wildcard)>1) Then Begin
  357.    { Load from list }
  358.    Delete (Wildcard,1,1);
  359.    If Wordy Then InfoLog^.Writelog ('Reading list '+Wildcard);
  360.    Assign (T,Wildcard);
  361.    {$I-}
  362.    Reset (T);
  363.    {$I+}
  364.    ErrorCheck ('Opening list');
  365.    {$I-}
  366.    While Not EOF(T) Do Begin
  367.     Readln (T,Filename);
  368.     {$I+}
  369.     ErrorCheck ('Reading list');
  370.     {$I-}
  371.     Dos.FindFirst(Filename,Archive,S);
  372.     If ((DosError=0) AND (S.Size>0)) Then Begin
  373.      DosError := 0;
  374.      DirCollection^.Insert(New(PDirItem,Init(S.Name,S.Size,S.Time,0)));
  375.     End;
  376.    End;
  377.    Close (T);
  378.    {$I+}
  379.    ErrorCheck ('Closing list');
  380.   End Else Begin
  381.    FindFirst(Wildcard, Archive, S);
  382.    while DosError = 0 do begin
  383.     If (S.Name<>ArchiveName) AND (S.Name<>DirectoryFilename) Then
  384.      DirCollection^.Insert(New(PDirItem,Init(S.Name,S.Size,S.Time,0)));
  385.     FindNext(S);
  386.    end;
  387.    DosError := 0;
  388.   End;
  389.   If DirCollection^.Count>0 Then Begin
  390.    { Update locations }
  391.    Location := 0;
  392.    For Count := 0 To (DirCollection^.Count-1) Do Begin
  393.     Item := PDirItem(DirCollection^.At(Count));
  394.     Item^.Position := Location;
  395.     Inc (Location,Item^.Filesize);
  396.     Inc (Location,SizeOf(TArchiveHeader)+SizeOf(TChecksum));
  397.    End;
  398.    { Store the directory as first file in the list }
  399.    WriteDirectory;
  400.    Dos.FindFirst(DirectoryFilename,Archive,S);
  401.    If DosError<>0 Then ErrorCheck('Adding directory');
  402.    DirCollection^.Insert(New(PDirItem,Init(DirectoryFilename,S.Size,S.Time,0)));
  403.    { Now add all files in the list to the archive }
  404.    For Count := 0 To (DirCollection^.Count-1) Do Begin
  405.     AddFile (PDirItem(DirCollection^.At(Count)));
  406.    End;
  407.   End Else
  408.    InfoLog^.Writelog ('Nothing to do');
  409.  End;
  410. End;
  411.  
  412. Procedure TArchiver.AddFile (Item : PDirItem);
  413. Var
  414.   F           : File;
  415.   Header      : TArchiveHeader;
  416.   BytesLeft   : Longint;
  417.   ToRead      : Word;
  418.   NumRead     : Word;
  419.   S           : String;
  420. Begin
  421.  { Open file }
  422.  Assign (F,Item^.Filename);
  423.  {$I-}
  424.  Reset (F,1);
  425.  {$I+}
  426.  ErrorCheck('Opening File '+Item^.Filename);
  427.  
  428.  { Make header }
  429.  Header.Magic    := MagicCode;
  430.  Header.Filename := Item^.Filename;
  431.  Header.Filesize := Item^.Filesize;
  432.  Header.Time     := Item^.Time;
  433.  { Counters }
  434.  INC (TotalFiles);
  435.  INC (TotalSize,Header.Filesize);
  436.  { Write header }
  437.  Put (@Header,SizeOf(Header));
  438.  Str (Header.Filesize,S);
  439.  Commas (S);
  440.  InfoLog^.Writelog ('Writing '+Copy(Header.Filename+'            ',1,12)+'  '+Copy('            ',1,12-Length(S))+S+' bytes');
  441.  
  442.  { Copy file }
  443.  Checksum := 0;
  444.  BytesLeft := Header.Filesize;
  445.  While BytesLeft>0 Do Begin
  446.   If BytesLeft>Blocksize Then
  447.    ToRead := BlockSize
  448.   Else
  449.    ToRead := BytesLeft;
  450.   {$I-}
  451.   BlockRead (F,FileBlock^,ToRead,NumRead);
  452.   {$I+}
  453.   ErrorCheck('Reading File');
  454.   INC(Checksum,CRC (FileBlock^,ToRead));
  455.   Put (FileBlock,ToRead);
  456.   Dec (BytesLeft,ToRead);
  457.  End;
  458.  
  459.  { Write Checksum }
  460.  Put (@Checksum,SizeOf(Checksum));
  461.  
  462.  { Close file }
  463.  {$I-}
  464.  Close (F);
  465.  {$I+}
  466.  ErrorCheck('Closing File');
  467. End;
  468.  
  469.  
  470. Procedure TArchiver.DisplayItem(Item : PDirItem);
  471. Var
  472.   S1,S2       : String;
  473. Begin
  474.  S1 := Copy(Item^.Filename+'            ',1,12);
  475.  If LongItemFlag Then Begin
  476.   Str (Item^.Filesize:8,S2);
  477.   S1 := S1+'   '+S2+'   '+TimeString(Item^.Time)+'   B';
  478.   Str (((Item^.Position+DirectorySize) DIV Blocksize)+1,S2);
  479.   S1 := S1+S2;
  480.  End;
  481.  InfoLog^.Writelog (S1);
  482. End;
  483.  
  484. Procedure TArchiver.ExtractNextFile;
  485. Var
  486.   F           : File;
  487.   Header      : TArchiveHeader;
  488.   BytesLeft   : Longint;
  489.   ToRead      : Word;
  490.   NumWritten  : Word;
  491.   NewChecksum : TChecksum;
  492.   S1,S2       : String;
  493. Begin
  494.  { Read header }
  495.  Get (@Header,SizeOf(Header));
  496.  If (Header.Magic=MagicCode) Then Begin
  497.   { Counters }
  498.   INC (TotalFiles);
  499.   INC (TotalSize,Header.Filesize);
  500.   InfoLog^.Writelog ('Extracting '+Header.Filename);
  501.   { Open file }
  502.   Assign (F,Header.Filename);
  503.   {$I-}
  504.   Rewrite (F,1);
  505.   {$I+}
  506.   ErrorCheck('Creating '+Header.Filename);
  507.   SetFTime (F,Header.Time);
  508.  
  509.   { Copy file }
  510.   Checksum := 0;
  511.   BytesLeft := Header.Filesize;
  512.   While BytesLeft>0 Do Begin
  513.    If BytesLeft>Blocksize Then
  514.     ToRead := Blocksize
  515.    Else
  516.     ToRead := BytesLeft;
  517.    Get (FileBlock,ToRead);
  518.    INC (Checksum,CRC (FileBlock^,ToRead));
  519.    {$I-}
  520.    BlockWrite (F,FileBlock^,ToRead,NumWritten);
  521.    {$I+}
  522.    ErrorCheck('Writing File');
  523.    Dec (BytesLeft,ToRead);
  524.   End;
  525.  
  526.   { Check Checksum }
  527.   Get (@NewChecksum,SizeOf(Checksum));
  528.   If Checksum<>NewChecksum Then Begin
  529.    Str (NewChecksum,S1);
  530.    Str (Checksum,S2);
  531.    ErrorLog^.Writelog ('Bad checksum: Checksum is '+S1+' instead of '+S2);
  532.   End;
  533.  
  534.   { Close file }
  535.   {$I-}
  536.   Close (F);
  537.   {$I+}
  538.   ErrorCheck('Closing File');
  539.  End Else
  540.   ErrorLog^.Writelog ('Bad header: Magic-Code is '+Copy(Header.Magic,1,Length(MagicCode))+' instead of '+MagicCode);
  541. End;
  542.  
  543. Procedure TArchiver.ExtractFiles (Wildcard : String);
  544. Var
  545.  T             : Text;
  546.  Item          : PDirItem;
  547.  Count         : Integer;
  548.  ItemNum       : Integer;
  549.  ItemBlock     : Longint;
  550.  Filename      : String[12];
  551.  Name,WName    : NameStr;
  552.  Ext,WExt      : ExtStr;
  553.  Filenames     : PStringCollection;
  554. Begin
  555.  If Length(Wildcard)>0 Then Begin
  556.   { Get the directory from the archive }
  557.   ExtractNextFile;
  558.   ReadDirectory;
  559.   { }
  560.   Wildcard := Upper(Wildcard);
  561.   If (Wildcard[1]='@') And (Length(Wildcard)>1) Then Begin
  562.    { Extract from external ASCII list }
  563.    New (Filenames,Init(20,20));
  564.    Delete (Wildcard,1,1);
  565.    If Wordy Then InfoLog^.Writelog ('Extracting from list '+Wildcard);
  566.    Assign (T,Wildcard);
  567.    {$I-}
  568.    Reset (T);
  569.    {$I+}
  570.    ErrorCheck ('Opening list');
  571.    {$I-}
  572.    While Not EOF(T) Do Begin
  573.     Readln (T,Filename);
  574.     {$I+}
  575.     ErrorCheck ('Reading list');
  576.     Filenames^.Insert(NewStr(Upper(Filename)))
  577.    End;
  578.    {$I-}
  579.    Close (T);
  580.    {$I+}
  581.    ErrorCheck ('Closing list');
  582.    { Now go through list }
  583.    If Filenames^.Count>0 Then Begin
  584.     For Count := 0 To (Filenames^.Count-1) Do Begin
  585.      Item^.Filename := PString(Filenames^.At(Count))^;
  586.      If DirCollection^.Search(Item,ItemNum) Then Begin
  587.       Item := PDirItem(DirCollection^.At(ItemNum));
  588.       If DisplayFlag Then
  589.        DisplayItem (Item)
  590.       Else Begin
  591.        { Relocate and extract }
  592.        ItemBlock  := (Longint(Item^.Position)+Longint(DirectorySize)) DIV Longint(Blocksize);
  593.        If ItemBlock<>BlockNum Then SeekBlock(ItemBlock);
  594.        BlockOfs := (Longint(Item^.Position)+Longint(DirectorySize)) MOD Longint(Blocksize);
  595.        ExtractNextFile;
  596.       End;
  597.      End;
  598.     End;
  599.     Dispose (Filenames,Done);
  600.    End Else
  601.     InfoLog^.Writelog ('Nothing to do');
  602.   End Else Begin
  603.    { Extract by matching wildcards }
  604.    If Wordy Then InfoLog^.Writelog ('Matching files with '+Wildcard);
  605.    If (Pos('.',Wildcard)<>0) Then Begin
  606.     WName := Copy(Wildcard,1,Pos('.',Wildcard)-1);
  607.     WExt := Copy(Wildcard,Pos('.',Wildcard)+1,3);
  608.    End Else Begin
  609.     WName := Wildcard;
  610.     WExt := '';
  611.    End;
  612.    If DirCollection^.Count>0 Then Begin
  613.     For ItemNum:=0 To (DirCollection^.Count-1) Do Begin
  614.      Item := PDirItem(DirCollection^.At(ItemNum));
  615.      If (Pos('.',Item^.Filename)<>0) Then Begin
  616.       Name := Copy(Item^.Filename,1,Pos('.',Item^.Filename)-1);
  617.       Ext := Copy(Item^.Filename,Pos('.',Item^.Filename)+1,3);
  618.      End Else Begin
  619.       Name := Item^.Filename;
  620.       Ext := '';
  621.      End;
  622.      If WildMatch (Name,WName,Ext,WExt) Then Begin
  623.       If DisplayFlag Then
  624.        DisplayItem (Item)
  625.       Else Begin
  626.        { Relocate and extract }
  627.        ItemBlock  := (Longint(Item^.Position)+Longint(DirectorySize)) DIV Longint(Blocksize);
  628.        If ItemBlock<>BlockNum Then SeekBlock(ItemBlock);
  629.        BlockOfs := (Longint(Item^.Position)+Longint(DirectorySize)) MOD Longint(Blocksize);
  630.        ExtractNextFile;
  631.       End;
  632.      End;
  633.     End;
  634.    End;
  635.   End;
  636.  End Else
  637.   InfoLog^.Writelog ('Nothing to do');
  638. End;
  639.  
  640. { Block primitives }
  641.  
  642. Procedure TArchiver.Put (Buffer : Pointer; Count : Word);
  643. Var
  644.   BlockLeft : Word;
  645.   BufLeft   : Word;
  646.   TransNum  : Word;
  647.   BytesLeft : Word;
  648. Begin
  649.  BufLeft := Count;                      { # of bytes to transfer   }
  650.  While BufLeft>0 Do Begin
  651.   BytesLeft := BlockSize-BlockOfs;      { # of bytes left in block }
  652.   TransNum := BytesLeft;
  653.   If BufLeft<BytesLeft Then TransNum:=BufLeft; { # to transfer now }
  654.   Move (PByteArray(Buffer)^[Count-BufLeft],Block^[BlockOfs],TransNum);
  655.   Inc (BlockOfs,TransNum);
  656.   Dec (BufLeft,TransNum);
  657.   If BlockOfs=BlockSize Then WriteBlock;
  658.  End;
  659. End;
  660.  
  661. Procedure TArchiver.Get (Buffer : Pointer; Count : Word);
  662. Var
  663.   BlockLeft : Word;
  664.   BufLeft   : Word;
  665.   TransNum  : Word;
  666.   BytesLeft : Word;
  667. Begin
  668.  BufLeft := Count;                        { # of bytes to transfer   }
  669.  While BufLeft>0 Do Begin
  670.   BytesLeft := BlockSize-BlockOfs;        { # of bytes left in block }
  671.   TransNum := BufLeft;
  672.   If BytesLeft<BufLeft Then TransNum:=BytesLeft; { # to transfer now }
  673.   Move (Block^[BlockOfs],PByteArray(Buffer)^[Count-BufLeft],TransNum);
  674.   Inc (BlockOfs,TransNum);
  675.   Dec (BufLeft,TransNum);
  676.   If BlockOfs=BlockSize Then ReadBlock;
  677.  End;
  678. End;
  679.  
  680. { virtual methods }
  681.  
  682. Procedure TArchiver.ReadBlock;
  683. Var
  684.  Result : Word;
  685. Begin
  686.  {$I-}
  687.  BlockRead (ArchiveFile,Block^,Blocksize,Result);
  688.  {$I+}
  689.  ErrorCheck('Reading block');
  690.  If Result<>Blocksize Then ErrorLog^.Writelog('Could not read complete block');
  691.  { Update counters }
  692.  BlockOfs := 0;
  693.  Inc (BlockNum);
  694. End;
  695.  
  696. Procedure TArchiver.WriteBlock;
  697. Var
  698.  Result : Word;
  699. Begin
  700.  If BlockOfs<Blocksize Then FillChar(Block^[BlockOfs],Blocksize-BlockOfs,0);
  701.  {$I-}
  702.  BlockWrite (ArchiveFile,Block^,Blocksize,Result);
  703.  {$I+}
  704.  ErrorCheck('Writing block');
  705.  If Result<>Blocksize Then ErrorLog^.Writelog('Could not write complete block');
  706.  BlockOfs := 0;
  707.  Inc (BlockNum);
  708. End;
  709.  
  710. Procedure TArchiver.SeekBlock (NewBlockNum : Longint);
  711. Var
  712.  L,LMax : Longint;
  713. Begin
  714.  If NewBlockNum>BlockNum Then Begin
  715.   LMax := NewBlockNum-BlockNum;
  716.   For L := 1 To LMax Do ReadBlock;
  717.  End;
  718. End;
  719.  
  720. Procedure TArchiver.OpenArchive;
  721. Begin
  722.  If Wordy Then InfoLog^.Writelog ('Opening archive file '+ArchiveFilename);
  723.  Assign (ArchiveFile,ArchiveFilename);
  724.  {$I-}
  725.  Case IOMode of
  726.   fRead:  Begin BlockNum := -1; Reset (ArchiveFile,1); ReadBlock; End;
  727.   fWrite: Begin BlockNum := 0; BlockOfs := 0; Rewrite (ArchiveFile,1); End;
  728.  End;
  729.  {$I+}
  730.  ErrorCheck ('Opening archive '+ArchiveFilename);
  731. End;
  732.  
  733. Procedure TArchiver.CloseArchive;
  734. Begin
  735.  If Wordy Then InfoLog^.Writelog ('Closing archive file '+ArchiveFilename);
  736.  If (IOMode=fWrite) AND (BlockOfs<>0) Then WriteBlock;
  737.  {$I+}
  738.  Close (ArchiveFile);
  739.  {$I+}
  740.  ErrorCheck ('Closing archive');
  741. End;
  742.  
  743. Begin
  744.  RegisterType (RDirItem);
  745.  RegisterType (RDirCollection);
  746. End.
  747.